POINT Software Programming/PPROG1.ISO/pascal/swag/textfile.swg/0049_Pascal Poetry.pas

Pascal/Delphi Source File | 1995-02-28 | 4.5 KB | 213 lines

UNIT PoetryU;

INTERFACE

VAR
  Vowels,
  Conson  : SET OF CHAR;

FUNCTION NumWords( S : STRING ) : INTEGER;
FUNCTION GetWord( S : STRING; WhichWord : INTEGER ) : STRING;
FUNCTION Word_Syll( S : STRING ) : INTEGER;
FUNCTION Sent_Syll( S : STRING ) : INTEGER;
FUNCTION UCase( S : STRING ) : STRING;

IMPLEMENTATION


FUNCTION UCase( S : STRING ) : STRING;
VAR
  Count : INTEGER;

Begin
  FOR Count := 1 TO Length( S ) DO
    S[ Count ] := UpCase( S[ Count ] );

  UCase := S;
End;

FUNCTION RightStr( S : STRING; Index : BYTE ) : STRING;
Begin
  RightStr := Copy( S, Index, Length( S ) );
End;

{ This function returns the number of words within a given string. }
FUNCTION NumWords( S : STRING ) : INTEGER;
VAR
  Words,
  Count : INTEGER;

Begin
  Words := 0;
  Count := 0;

  S := UCase( S );

  WHILE Count <> Length( S ) DO
  Begin
    INC( Count );

    IF S[Count] IN ['A'..'Z'] THEN
    Begin
      INC( Words );

      WHILE (S[Count] IN ['A'..'Z', '''']) AND (Count < Length( S )) DO
        INC( Count );
    End;
  End;

  NumWords := Words;
End;

{ This function will return a word (1st, 2nd, 3rd, etc) from a sentence.
  Note that it converts the word to uppercase. }
FUNCTION GetWord( S : STRING; WhichWord : INTEGER ) : STRING;
VAR
  WC,
  Count : INTEGER;
  Temp  : STRING;

Begin
  WC    := 0;
  Count := 0;
  Temp  := '';

  IF WhichWord > NumWords( S ) THEN
  Begin
    GetWord := '';
    Exit;
  End;

  S := UCase( S );

  WHILE Count < Length( S ) DO
  Begin
    INC( Count );

    IF S[Count] IN ['A'..'Z'] THEN
    Begin
      INC( WC );

      IF WC = WhichWord THEN
        WHILE (S[Count] IN ['A'..'Z']) AND (Count <= Length( S )) DO
        Begin
          Temp := Temp + S[Count];
          INC( Count );
        End
      ELSE
        WHILE (S[Count] IN ['A'..'Z']) AND (Count <= Length( S )) DO
          INC( Count );
    End;
  End;

  GetWord := Temp;
End;

{ This function will return the number of syllables in a given word.
  It is in no way a fool-proof function, but will work for a lot of words. }
FUNCTION Word_Syll( S : STRING ) : INTEGER;
VAR
  Count,
  SylCount : INTEGER;

Begin
  { No syllables! }
  SylCount := 0;

  S := UCase( S );

  { If it starts with a vowel, there is a good chance an extra syllable is in
    there. }
  IF (S[1] IN Vowels) AND (Length( S ) > 3) THEN
    SylCount := 1;

  IF (Pos( 'IO', S ) > 0) THEN
    INC( SylCount );
  IF (Pos( 'EO', S ) > 0) THEN
    INC( SylCount );
  IF (Pos( 'IA', S ) > 0) THEN
    INC( SylCount );
  IF (Pos( 'ISM', S ) > 0) THEN
    INC( SylCount );
  IF ((Pos( 'UA', S ) > 0) AND (Pos( 'QUA', S ) = 0)) THEN
    INC( SylCount );
  IF (Pos( 'TION', S ) OR (Pos( 'SION', S )) <> 0) THEN
    DEC( SylCount );

  FOR Count := 1 TO (Length( S ) - 1) DO
    IF (S[Count] IN Conson) AND (S[Count + 1] IN Vowels) THEN
      INC( SylCount );

  IF (S[Length( S )] = 'E') AND (Pos( 'BLE', RightStr( S, 3 )) = 0) AND
     (Pos( 'IE',  RightStr( S, 2 )) = 0) AND
     (Pos( 'TLE', RightStr( S, 3 )) = 0) THEN
    DEC( SylCount );

  { A word must have at least 1 syllable!! }
  IF SylCount < 1 THEN
    SylCount := 1;

  Word_Syll := SylCount;
End;

{ This function will count the number of syllables in a given sentence. }
FUNCTION Sent_Syll( S : STRING ) : INTEGER;
VAR
  Count,
  SylCount : INTEGER;
  Temp     : STRING;

Begin
  SylCount := 0;

  FOR Count := 1 TO NumWords( S ) DO
    INC( SylCount, Word_Syll( GetWord( S, Count ) ) );

  Sent_Syll := SylCount;
End;

PROCEDURE InitVowels;
Begin
  Vowels := ['A', 'E', 'I', 'O', 'U', 'Y'];
End;

PROCEDURE InitConson;
VAR
  Ch : CHAR;

Begin
  Conson := [];

  FOR Ch := 'A' TO 'Z' DO
    IF NOT (Ch IN Vowels) THEN
      Conson := Conson + [ Ch ];
End;

BEGIN
  InitVowels;
  InitConson;
END.

{ -------------------------  DEMO ----------------------- }


USES Crt, PoetryU;

CONST
  TEST = 'These are a few interesting functions, man.';
 {TEST = 'antidisestablishmentarianism';}

VAR
  AWord : STRING;

BEGIN
  ClrScr;

  AWord := GetWord( TEST, NumWords( TEST ) );

  WriteLn( 'The last word is : ', AWord );
  WriteLn( '# of syllables   : ', Word_Syll( AWord ) );
  WriteLn( 'Total # of words : ', NumWords( TEST ) );
  WriteLn( 'Total syllables  : ', Sent_Syll( TEST ) );
END.